\ ADDRESS.SCR: the address-book example Ham 12:00 11/01/92 \ This file contains the complete set of code to run the \ address book developed in the book. The code is lightly \ commented because you know its operation from the book; \ if you were passing this code along to someone else, you \ would review the code with them and add comments as needed. \ Cursor words PCKEY PRESS L>1 Ham 12:00 11/01/92 : BIGCUR 0 14 SET-CUR ; \ large cursor for Ins mode : SMLCUR 6 7 SET-CUR ; \ small cursor for Overtype mode : NOCUR 14 0 SET-CUR ; \ no cursor for most work : PCKEY ( -- ASCII-char -1 | IBM-special_char 0 ) KEY ?DUP IF TRUE ELSE KEY FALSE THEN ; : PRESS NOCUR ." Press any key to continue." PCKEY 2DROP ; : L>1 ( char - char' ) DUP ASCII L = OVER ASCII l = OR IF DROP ASCII 1 THEN ; : CNOTICE " Forth nucleus Copyright (C) 1987 LMI" ; \ Required in distributed programs using this Forth. \ BELL CAPITALIZE INCR DECR -CAPS Ham 12:00 11/01/92 CREATE NOISE -1 , \ True (default) = sound bell : BELL NOISE @ IF 440 20 BEEP THEN ; : CAPITALIZE ( char - CHAR ) DUP ASCII a >= OVER ASCII z <= AND IF BL - THEN ; : ECHO ( n - n ) DUP 31 > IF DUP EMIT 8 EMIT THEN ; : INCR ( adr - ) 1 SWAP +! ; \ increment variable by 1 : DECR ( adr - ) -1 SWAP +! ; \ decrement variable by 1 WSIZE 2 = .IF 0 CONSTANT DOS0 .THEN \ for 16-bit Forth : -CAPS DOS0 1047 C@L \ fetch contents at location 0 1047 191 AND \ turn off bit 6 DOS0 1047 C!L ; \ store result back at location 0 1047 \ @KEY Y/N TITLE word Ham 12:00 11/01/92 : @KEY ( - ASCII-key ) BEGIN PCKEY NOT WHILE DROP BELL REPEAT ; : Y/N ( - flag ) ." (Y/N)? " BEGIN @KEY CAPITALIZE ECHO DUP ASCII Y <> OVER ASCII N <> AND WHILE DROP BELL REPEAT DUP EMIT ASCII Y = ; : TITLE CLS -CAPS \ turn off Caps-lock for entire program 32 4 GOTOXY REVERSE ." ADDRESS BOOK " -REVERSE 31 6 GOTOXY INTENSITY ." By Gnu Programmer" -INTENSITY 22 12 GOTOXY ." Copyright (c) 1989 by Gnu Programmer" 30 14 GOTOXY ." All rights reserved." 27 20 GOTOXY PRESS ; \ Option arithmetic Ham 12:00 11/01/92 0 EQU OPTIONS \ the address of array of options 0 EQU #OPTS \ the number of options 0 EQU #/COL \ the number of elements in a column : OPCLIP ( # - #' ) #OPTS MOD ; \ keep opt # in range : PLAIN ( # - ) WSIZE * OPTIONS + PERFORM ; \ option plain : FANCY ( # - ) REVERSE PLAIN -REVERSE ; \ option inversed : SHOWALL ( # - # ) #OPTS 0 DO I 2DUP = IF FANCY ELSE PLAIN THEN LOOP ; \ SHOWALL expects the default option number on the stack and \ leaves it there. \ Key equivalents (constants) Ham 12:00 11/01/92 71 CONSTANT HOMEKEY 82 CONSTANT INSKEY 79 CONSTANT ENDKEY 83 CONSTANT DELKEY 75 CONSTANT LEFTKEY 72 CONSTANT UPKEY 77 CONSTANT RIGHTKEY 80 CONSTANT DOWNKEY 59 CONSTANT F1KEY 81 CONSTANT PGDNKEY 15 CONSTANT LTABKEY 73 CONSTANT PGUPKEY 9 CONSTANT TABKEY 27 CONSTANT ESCKEY 13 CONSTANT ENTERKEY 8 CONSTANT BSPKEY \ TABKEY, ESCKEY, ENTERKEY, and BSPKEY are all ASCII values. \ Others are the characteristic values of the "special" IBM keys \ Options for menu Ham 12:00 11/01/92 : "0. 27 5 GOTOXY ." 1. Enter new addresses " ; : "1. 27 7 GOTOXY ." 2. Review/revise addresses " ; : "2. 27 9 GOTOXY ." 3. Print address book " ; : "3. 27 11 GOTOXY ." 4. Exit to DOS" 13 SPACES ; \ An alternative "cursor" structure is to trim trailing blanks \ instead of padding with blanks to make options the same length CREATE OPTIONS-3 ] "0. "1. "2. "3. [ : SETUP3 NOISE ON 4 EQU #OPTS 4 EQU #/COL OPTIONS-3 EQU OPTIONS ; \ GETOPTION tools Ham 12:00 11/01/92 : #&OK? ( char - flag ) \ true if number in range DUP ASCII 0 > \ number must be greater than 0 SWAP ASCII 1 #OPTS + < AND ; \ & less than #OPTS + 1 : #WORK ( # char - #' ) \ clean up display, leave choice SWAP PLAIN \ turn off old option ASCII 1 - \ convert character to zero-based option # DUP FANCY ; \ show new option \ Notice that GETOPTION on the next screen has been revised \ to exit when Esc is pressed; this is necessary for consistency\ in this program. \ GETOPTION itself Ham 12:00 11/01/92 : GETOPTION ( # - # ) \ default option on stack or stack empty NOCUR DEPTH 0= IF 0 THEN SHOWALL BEGIN PCKEY IF ( ascii ) L>1 DUP #&OK? IF ( number ) #WORK TRUE ELSE ( not a number ) CASE ESCKEY OF DROP BYE ENDOF ENTERKEY OF TRUE ( to exit ) ENDOF BL OF DUP PLAIN 1+ OPCLIP DUP FANCY FALSE ENDOF TABKEY OF DUP PLAIN #/COL + OPCLIP DUP FANCY FALSE ENDOF BELL FALSE SWAP ENDCASE THEN ELSE ( special key ) OVER PLAIN CASE UPKEY OF 1- ENDOF DOWNKEY OF 1+ ENDOF LEFTKEY OF 1- ENDOF RIGHTKEY OF 1+ ENDOF LTABKEY OF 1- ENDOF BELL ENDCASE OPCLIP DUP FANCY FALSE THEN UNTIL ; \ Modified for a single column of options. \ $GET sequence EQUs OFFSET LEFTMOST? etc. Ham 12:00 11/01/92 0 EQU CHARS \ maximum number of characters to collect 0 EQU STRING \ address of first byte of string storage \ (past the count byte if any) 0 EQU X \ x-coordinate (col) of original cursor locn 0 EQU Y \ y-coordinate (row) of original cursor locn VARIABLE LEGAL? \ holds edit routine for legal keys : OFFSET ( - n ) ?XY DROP X - ; \ current offset into string : LEFTMOST? ( - flag ) OFFSET 0= ; \ true = left end : RIGHTMOST? ( - flag ) OFFSET CHARS 1- = ; \ true = right end \ BACK LEFT RIGHT CURSOR INS Ham 12:00 11/01/92 VARIABLE FIRST \ true after first character in last position : BACK 8 EMIT FIRST OFF ; : LEFT LEFTMOST? IF BELL ELSE BACK THEN ; : RIGHT RIGHTMOST? IF BELL ELSE ?XY SWAP 1+ SWAP GOTOXY THEN ; VARIABLE INS? \ true if insert mode : CURSOR INS? @ IF BIGCUR ELSE SMLCUR THEN ; : INS INS? @ 0= INS? ! CURSOR ; \ HOME SETUP OVERTYPE Ham 12:00 11/01/92 : HOME X Y GOTOXY FIRST OFF ; : SETUP ( adr cnt - ) EQU CHARS EQU STRING ?XY EQU Y EQU X STRING CHARS TYPE CURSOR HOME FIRST OFF ; : OVERTYPE ( c - ) RIGHTMOST? SWAP ( save the flag for later ) DUP STRING OFFSET + C! EMIT IF ( rightmost ) FIRST @ IF BELL THEN BACK FIRST ON THEN ; \ PULL Ham 12:00 11/01/92 : PULL STRING OFFSET + \ current loc in string: dest DUP 1+ \ 1st char past current loc: source SWAP \ to put source and dest in order CHARS OFFSET - \ # of chars from cursor to right 1- \ # of chars strictly right of cursor CMOVE \ copy chars BL STRING CHARS 1- + C! ; \ & blank out char at end \ PUSH REFRESH DELETE Ham 12:00 11/01/92 : PUSH STRING OFFSET + \ current location in string DUP 1+ \ 1st char past current location CHARS OFFSET - \ # of chars from cursor to right 1- \ # of chars strictly right of cursor CMOVE> ; \ copy characters from right : REFRESH ?XY OFFSET DUP STRING + ( adr ) CHARS ROT - ( # of char ) TYPE GOTOXY ; : DELETE PULL REFRESH FIRST OFF ; \ BACKSPACE INSERT Ham 12:00 11/01/92 : BACKSPACE LEFTMOST? IF BELL ELSE BACK DELETE THEN ; : PUSHED? ( - f ) STRING CHARS 1- + C@ BL <> ; \ true if a last character is nonblank & thus pushed off end : INSERT ( c - ) RIGHTMOST? IF FIRST @ NOT PUSHED? AND IF BELL THEN OVERTYPE ELSE PUSHED? IF BELL ( character pushed off ) THEN PUSH STRING OFFSET + C! REFRESH RIGHT THEN ; \ TAIL END ALEGALKEYS Ham 12:00 11/01/92 : TAIL ( - offset ) \ leave offset for END: 1 past last char STRING CHARS -TRAILING NIP CHARS 1- MIN ; : END X TAIL + Y GOTOXY ; : ALEGALKEYS ( c - flag ) DUP 31 > SWAP 127 < AND ; \ leave true flag for characters from blank through ~ \ AREGKEYS ASPECKEYS Ham 12:00 11/01/92 : AREGKEYS ( c - flag ) CAPITALIZE DUP LEGAL? PERFORM IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ESCKEY OF -REVERSE BYE ENDOF ENTERKEY OF TRUE ( quits ) ENDOF BELL FALSE SWAP ENDCASE THEN ; : ASPECKEYS ( c - 0 ) CASE HOMEKEY OF HOME ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF ENDKEY OF END ENDOF BELL ENDCASE FALSE ; \ These are the words to get the filename; no up-arrow or \ down-arrow allowed. Letters are capitalized by routine. \ ESCAPE UP DOWN Ham 12:00 11/01/92 VARIABLE WHICH \ holds number of current entry field VARIABLE DONE \ true = finished getting new entries 7 CONSTANT LASTFIELD \ last data field (telephone) : ESCAPE ( - flag ) DONE ON TRUE ; : UP ( - flag ) WHICH @ DUP IF WHICH DECR ELSE BELL THEN ; : DOWN ( - flag ) WHICH @ LASTFIELD <> DUP IF WHICH INCR ELSE BELL THEN ; \ $GET with variable action Ham 12:00 11/01/92 VARIABLE REGULAR \ holds routine for regular keys VARIABLE SPECIAL \ holds routine for special keys : $GET ( adr count - ) REVERSE SETUP BEGIN PCKEY IF ( regular key ) REGULAR PERFORM ELSE ( special key ) SPECIAL PERFORM THEN UNTIL -REVERSE ; : $GETC ( adr count - ) \ assume count byte is at STRING-1 $GET CHARS STRING 1- C! ; \ GETENTRY development WORKAREA Ham 12:00 11/01/92 200 CONSTANT MAXRECS \ maximum number of records allowed 138 CONSTANT RECSIZE \ number of bytes per record CREATE WORKAREA MAXRECS RECSIZE * ALLOT \ Be careful not to load multiple copies of WORKAREA. At \ 27,600 bytes, it can overflow the 65,536 bytes of the \ dictionary space and crash the system. : SLOT ( n - adr ) RECSIZE * WORKAREA + ; \ #RECS CHANGE FILE NEW SCRTITLE Ham 12:00 11/01/92 VARIABLE #RECS \ number of records currently in work area VARIABLE CHANGE \ true = work area contents have been changed CREATE FILE 33 ALLOT CREATE NEW RECSIZE ALLOT : SCRTITLE 33 0 GOTOXY ." My Address Book" FILE COUNT 40 OVER 2/ - 2 GOTOXY TYPE ; \ RECORD GETFILE PUTFILE Ham 12:00 11/01/92 7 CONSTANT #/BLOCK ( 7 records per block ) : RECORD ( n - adr ) #/BLOCK /MOD BLOCK SWAP RECSIZE * + ; : GETFILE #RECS OFF CHANGE OFF ?SCREENS #/BLOCK * 0 DO I RECORD DUP C@ BL = IF DROP LEAVE THEN I SLOT RECSIZE CMOVE #RECS INCR #RECS @ MAXRECS = IF LEAVE THEN LOOP CLOSE-SCR ; \ cuts off at maximum no. of records : PUTFILE CHANGE @ IF FILE OPEN-SCR DROP ( status ) #RECS @ 0 ?DO I SLOT I RECORD RECSIZE CMOVE UPDATE LOOP BL #RECS @ RECORD C! \ marks the end of the active record UPDATE FLUSH CLOSE-SCR CHANGE OFF THEN NEW RECSIZE BLANK ; \ Words for NEW-ENTRY Ham 12:00 11/01/92 : 2CR CR CR ; \ just to save a little room : >FIELD ( - adr ) 13 OUT @ - SPACES REVERSE NEW ; \ >FIELD is a nonce word to save room in the definition; it \ contains the repetitions from the various lines of NEW-ENTRY \ NEW-ENTRY's components Ham 12:00 11/01/92 : RECS-REMAINING 27 4 GOTOXY ." New Address Entry Screen" 2CR ." Number of record slots remaining:" MAXRECS #RECS @ - 5 .R ; : SHOW-REC 2CR ." Last Name:" >FIELD 16 TYPE -REVERSE 2CR ." First Name:" >FIELD 16 + 12 TYPE -REVERSE 2CR ." Address 1:" >FIELD 28 + 30 TYPE -REVERSE 2CR ." Address 2:" >FIELD 58 + 30 TYPE -REVERSE 2CR ." City:" >FIELD 88 + 25 TYPE -REVERSE 2CR ." State:" >FIELD 113 + 2 TYPE -REVERSE 2CR ." ZIP:" >FIELD 115 + 10 TYPE -REVERSE 2CR ." Telephone:" >FIELD 125 + 13 TYPE -REVERSE ; : F1MSG 0 24 GOTOXY CLREOL 29 SPACES ." Press F1 for help." ; \ NEW-ENTRY HELP AFTER? Ham 12:00 11/01/92 : NEW-ENTRY NOCUR SCRTITLE RECS-REMAINING SHOW-REC F1MSG ; \ display entry for add (new version of NEW-ENTRY) : HELP ?XY -REVERSE ( because called from within data field ) CLS SCRTITLE 29 6 GOTOXY ." Enter data as labeled." 25 8 GOTOXY ." Leading blanks are not accepted." 27 21 GOTOXY PRESS CLS NEW-ENTRY GOTOXY REVERSE CURSOR ; \ Note turning off cursor to improve display. : AFTER? ( n - flag ) SLOT 28 NEW 28 STRCMP 0< ; \ ALL-BLANK? FIND-SPOT Ham 12:00 11/01/92 : ALL-BLANK? ( - flag ) PAD 16 BLANK PAD 16 NEW 16 STRCMP 0= ; : FIND-SPOT ( - n ) \ leaves slot number where to insert NEW #RECS @ DUP IF 1- 0 SWAP \ low and high slot BEGIN 2DUP < WHILE 2DUP + 2/ DUP AFTER? IF ROT DROP 1+ ( low +1 ) SWAP ELSE NIP ( high ) THEN REPEAT DROP ( high ) DUP ( low ) AFTER? IF 1+ THEN THEN ; \ SLIDE TRANSFER !RECORD Ham 12:00 11/01/92 \ If WORKAREA has no records, 0 characters are moved by SLIDE. : SLIDE ( n - ) \ n = slot into which record is to be moved DUP SLOT \ location of this record DUP RECSIZE + \ location of next record ROT #RECS @ SWAP - \ no. of records to slide over RECSIZE * \ no. of chars to slide over CMOVE> ; \ from lower to higher : TRANSFER ( n - ) NEW SWAP SLOT RECSIZE CMOVE ; : !RECORD ( n - ) DUP SLIDE TRANSFER ; \ SAVE-RECORD CHECK-MAX FIXLAST Ham 12:00 11/01/92 VARIABLE ALTERED \ true = record altered in REVIEW routine : SAVE-RECORD FIND-SPOT !RECORD #RECS INCR NEW RECSIZE BLANK CHANGE ON ALTERED OFF ; : CHECK-MAX #RECS @ MAXRECS = IF 0 24 GOTOXY CLREOL ." File full. Ending new entries. " BELL PRESS DONE ON ELSE -REVERSE NEW-ENTRY REVERSE THEN ; : DELFIRST NEW 1+ NEW 15 CMOVE BL NEW 15 + C! ; \ slide Last-name over to delete character in 1st position : FIXLAST BEGIN NEW C@ BL = WHILE DELFIRST REPEAT ; \ ENTER POSITION-CURSOR ADDR-LENGTH Ham 12:00 11/01/92 : ENTER ( - -1 ) WHICH @ ?DUP IF LASTFIELD = IF FIXLAST SAVE-RECORD CHECK-MAX WHICH OFF ELSE WHICH INCR THEN ELSE ALL-BLANK? IF DONE ON ELSE WHICH INCR THEN THEN TRUE ; : POSITION-CURSOR 13 WHICH @ 2* 8 + GOTOXY ; CREATE A/L NEW 16 , , NEW 16 + 12 , , NEW 28 + 30 , , NEW 58 + 30 , , NEW 88 + 25 , , NEW 113 + 2 , , NEW 115 + 10 , , NEW 125 + 13 , , : ADDR-LENGTH ( - adr n ) WHICH @ WSIZE 2* * A/L + 2@ ; \ BLEGALKEYS BEREGKEYS Ham 12:00 11/01/92 : BLEGALKEYS ( c - flag ) DUP 31 > OVER 127 < AND SWAP BL = OFFSET 0= AND NOT AND ; : BREGKEYS ( c - flag ) DUP LEGAL? PERFORM IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ENTERKEY OF ENTER ENDOF ESCKEY OF ESCAPE ENDOF TABKEY OF DOWN ENDOF BELL FALSE SWAP ENDCASE THEN ; \ BSPECKEYS Ham 12:00 11/01/92 : BSPECKEYS ( c - flag ) FALSE SWAP ( put character on top ) CASE HOMEKEY OF HOME ENDOF ENDKEY OF END ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ENDOF INSKEY OF INS ENDOF LTABKEY OF DROP UP ENDOF UPKEY OF DROP UP ENDOF DOWNKEY OF DROP DOWN ENDOF F1KEY OF HELP ENDOF BELL ENDCASE ; \ This set of key-handlers are for GETENTRY, in which the \ up-arrow and down-arrow are legal to move from field to \ field and which has a help key. \ TRIM ASETUP BSETUP GETFNAME Ham 12:00 11/01/92 : TRIM ( adr - ) DUP COUNT -TRAILING ROT C! DROP ; \ trims the string whose count byte is adr to proper length. \ $GETC stores the maximum string count; trailing blanks can \ easily be trimmed with TRIM : ASETUP ['] AREGKEYS REGULAR ! ['] ASPECKEYS SPECIAL ! ['] ALEGALKEYS LEGAL? ! ; : BSETUP ['] BREGKEYS REGULAR ! ['] BSPECKEYS SPECIAL ! ['] BLEGALKEYS LEGAL? ! ; : GETFNAME ASETUP ( for first version of $GET ) FILE 1+ 32 $GETC FILE TRIM ; \ OPEN-FILE Ham 12:00 11/01/92 : OPEN-FILE CLS FILE 33 BLANK ( initialize area ) SCRTITLE BEGIN 10 10 GOTOXY ." Enter name of address file: " GETFNAME FILE OPEN-SCR WHILE ( failed ) CR CR 10 SPACES BELL ." No file found with name " FILE COUNT TYPE ." ." CR CR 10 SPACES ." Do you want to re-enter the name " Y/N IF 0 12 GOTOXY CLREOL 0 14 GOTOXY CLREOL FILE 33 BLANK ( try again ) ELSE BYE THEN REPEAT ; \ GETENTRY itself Ham 12:00 11/01/92 : GETENTRY CLS #RECS @ MAXRECS = IF SCRTITLE 2CR ." No further room in file." 2CR PRESS ELSE NEW RECSIZE BLANK NEW-ENTRY WHICH OFF DONE OFF BSETUP BEGIN POSITION-CURSOR ADDR-LENGTH $GET DONE @ UNTIL PUTFILE THEN ; \ THIS REC-LOC SHOW-ENTRY @RECORD Ham 12:00 11/01/92 0 EQU THIS \ slot number of record on display : REC-LOC 27 4 GOTOXY ." Review/revision Screen" 2CR ." Record " THIS 1+ . ." of " #RECS @ . 2 SPACES ; : F1MSG2 0 24 GOTOXY CLREOL 23 SPACES ." Press F1 for help, Esc to exit." ; : SHOW-ENTRY NOCUR SCRTITLE REC-LOC SHOW-REC F1MSG2 ; \ display entry for review/revise : @RECORD ( n - ) DUP EQU THIS SLOT NEW RECSIZE CMOVE ALTERED OFF ; \ move record in slot n into NEW \ DELREC Ham 12:00 11/01/92 : DELREC ( n - ) \ n = slot from which record is to be deleted DUP SLOT \ location of this record DUP RECSIZE + \ location of next record SWAP \ source=next, destination=this ROT #RECS @ SWAP - \ no. of records to slide down RECSIZE * \ no. of chars to slide down CMOVE \ from higher to lower #RECS DECR \ one fewer records CHANGE ON ; \ and work area has been changed \ GOTONEXT PGUP PGDN Ham 12:00 11/01/92 : GOTONEXT ( n - ) \ replace current rec with rec # on stack -REVERSE \ usually running in REVERSE ALTERED @ \ was record modified? IF THIS DELREC \ if yes, delete old version SAVE-RECORD THEN \ and save new version DUP EQU THIS \ save new slot number in THIS @RECORD \ bring in next record SHOW-ENTRY \ and display it WHICH OFF \ with cursor at start REVERSE ; \ back to REVERSE \ PGUP LASTSLOT PGDN Ham 12:00 11/01/92 : PGUP ( - flag ) THIS ?DUP IF 1- GOTONEXT TRUE ELSE BELL FALSE THEN ; : LASTSLOT ( - n ) #RECS @ 1- ; \ last slot # is 1 less than # of recs because 1st slot = 0 : PGDN ( -f) THIS DUP LASTSLOT = IF DROP BELL FALSE ELSE 1+ GOTONEXT TRUE THEN ; : ENTER2 ( - -1 ) WHICH @ ?DUP IF LASTFIELD = IF THIS 1+ LASTSLOT MIN GOTONEXT ELSE WHICH INCR THEN ELSE ALL-BLANK? IF DONE ON ELSE WHICH INCR THEN THEN TRUE ; \ HELP2 Ham 12:00 11/01/92 63 CONSTANT F5KEY 68 CONSTANT F10KEY : HELP2 ?XY -REVERSE ( called from data field ) CLS SCRTITLE 22 6 GOTOXY ." F5 deletes the current record." 22 8 GOTOXY ." PgUp moves to the previous record." 22 10 GOTOXY ." PgDn moves to the subsequent record." 22 12 GOTOXY ." F10 searches on last name." 22 14 GOTOXY ." Esc returns to main menu." 27 21 GOTOXY PRESS CLS SHOW-ENTRY GOTOXY REVERSE CURSOR ; \ DELETE? F5 Ham 12:00 11/01/92 : DELETE? ( - flag ) -REVERSE 0 24 GOTOXY CLREOL 28 SPACES INTENSITY ." Delete this record " Y/N -INTENSITY REVERSE ; : F5 ?XY DELETE? IF 2DROP ( x and y ) ALTERED OFF ( makes no diff; rec gone ) THIS DELREC #RECS @ ( any records left? ) IF THIS LASTSLOT MIN GOTONEXT TRUE ELSE ( no recs left ) -REVERSE 0 24 GOTOXY CLREOL ." File is now empty. Exiting review/revision. " BELL PRESS REVERSE DONE ON TRUE THEN ELSE -REVERSE F1MSG2 REVERSE GOTOXY FALSE THEN ; \ F10REGKEYS F10SETUP Ham 12:00 11/01/92 VARIABLE ESCAPED \ true = exited with Esc key : F10REGKEYS ( c - flag ) DUP LEGAL? PERFORM IF INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF BACKSPACE FALSE ENDOF ENTERKEY OF TRUE ENDOF ESCKEY OF ESCAPED ON TRUE ENDOF \ F10's ESC BELL FALSE SWAP ENDCASE THEN ; : F10SETUP ['] BLEGALKEYS LEGAL? ! ['] F10REGKEYS REGULAR ! ['] ASPECKEYS SPECIAL ! ; \ Set up $GET for F10. Will have to preserve and restore \ former contents of the variables. See next screen. \ $SEARCH F10 Ham 12:00 11/01/92 : $SEARCH SPECIAL @ REGULAR @ LEGAL? @ \ save variables F10SETUP NEW 16 $GET \ get search string LEGAL? ! REGULAR ! SPECIAL ! ; \ restore variables : F10 ?XY ALTERED @ IF THIS DELREC SAVE-RECORD THEN NEW RECSIZE BLANK -REVERSE 0 24 GOTOXY CLREOL ." Enter last name for search: " ?XY ( mark spot ) 18 SPACES ." (Esc quits without search.)" GOTOXY ( to spot ) ESCAPED OFF $SEARCH REVERSE ESCAPED @ IF THIS @RECORD -REVERSE F1MSG2 REVERSE GOTOXY FALSE ELSE 2DROP ( x y from beginning ) FIND-SPOT DUP LASTSLOT > + ( add flag ) GOTONEXT TRUE THEN ; \ RREGKEYS Ham 12:00 11/01/92 : RREGKEYS ( c - flag ) DUP LEGAL? PERFORM IF ALTERED ON INS? @ IF INSERT ELSE OVERTYPE THEN FALSE ELSE CASE BSPKEY OF ALTERED ON BACKSPACE FALSE ENDOF ENTERKEY OF ENTER2 ENDOF ESCKEY OF ESCAPE ENDOF TABKEY OF DOWN ENDOF BELL FALSE SWAP ENDCASE THEN ; \ RSPECKEYS Ham 12:00 11/01/92 : RSPECKEYS ( c - flag ) FALSE SWAP ( char on top ) CASE HOMEKEY OF HOME ENDOF ENDKEY OF END ENDOF LEFTKEY OF LEFT ENDOF RIGHTKEY OF RIGHT ENDOF DELKEY OF DELETE ALTERED ON ENDOF INSKEY OF INS ENDOF LTABKEY OF DROP UP ENDOF UPKEY OF DROP UP ENDOF DOWNKEY OF DROP DOWN ENDOF F1KEY OF HELP2 ENDOF PGUPKEY OF DROP PGUP ENDOF PGDNKEY OF DROP PGDN ENDOF F5KEY OF DROP F5 ENDOF F10KEY OF DROP F10 ENDOF BELL ENDCASE ; \ REVIEW Ham 12:00 11/01/92 : REVIEW CLS #RECS @ IF ALTERED OFF DONE OFF REVERSE 0 GOTONEXT -REVERSE ['] BLEGALKEYS LEGAL? ! ['] RREGKEYS REGULAR ! ['] RSPECKEYS SPECIAL ! BEGIN POSITION-CURSOR ADDR-LENGTH $GET DONE @ UNTIL PUTFILE NEW RECSIZE BLANK ELSE SCRTITLE 2CR ." No records on file. " PRESS THEN ; \ CRs PTITLE .PAGE Ham 12:00 11/01/92 : CRs ( n - ) 0 ?DO CR LOOP ; 0 EQU LINE# 0 EQU PAGE# : PTITLE 6 CRs 10 SPACES ." My Address Book" 2CR 9 EQU LINE# ; : .PAGE ." Page" PAGE# 3 .R ; \ Using 3 .R instead of 2 .R puts a blank following the word \ "Page" without using an extra byte in the definition (as \ would be required if ." Page " were used to get the blank). \ LINEn? Ham 12:00 11/01/92 : LINE2? ( - flag ) \ T if line 2 not blank PAD 30 BLANK PAD 30 NEW 28 + 30 STRCMP 0<> ; : LINE3? ( - flag ) \ T if line 3 not blank PAD 30 BLANK PAD 30 NEW 58 + 30 STRCMP 0<> ; : LINE4? ( - flag ) \ T if line 4 not blank PAD 37 BLANK PAD 37 NEW 88 + 37 STRCMP 0<> ; : #LINES ( - n ) \ number of lines required by current entry 2 LINE2? - LINE3? - LINE4? - ; \ LINEn Ham 12:00 11/01/92 : MARGIN CR 10 SPACES ; : LINE1 \ print last name, first name phone no. MARGIN NEW 16 -TRAILING TYPE ASCII , EMIT ( last name ) SPACE NEW 16 + 12 -TRAILING TYPE ( first name ) 62 OUT @ - SPACES ( to start of phone field ) NEW 124 + 13 -TRAILING 13 OVER - SPACES ( no. flush rt ) TYPE ; : LINE2 LINE2? IF MARGIN NEW 28 + 30 -TRAILING TYPE THEN ; : LINE3 LINE3? IF MARGIN NEW 58 + 30 -TRAILING TYPE THEN ; \ LINE4 Ham 12:00 11/01/92 : LINE4 LINE4? IF MARGIN NEW 88 + 25 -TRAILING TYPE ASCII , EMIT SPACE NEW 113 + 2 -TRAILING TYPE 2 SPACES NEW 115 + 10 -TRAILING TYPE THEN ; \ PRINT-ENTRY PAGE FOOTER Ham 12:00 11/01/92 : PRINT-ENTRY LINE1 LINE2? IF LINE2 THEN LINE3? IF LINE3 THEN LINE4? IF LINE4 THEN CR LINE# #LINES + EQU LINE# ; : PAGE 12 EMIT ; : FOOTER 60 LINE# ?DO CR LOOP \ get to bottom of page 10 SPACES \ left margin ." File: " SCRHCB .FNAME \ print filename 69 OUT @ - SPACES \ move to print flush right .PAGE \ print page number PAGE# 1+ EQU PAGE# \ increment page number PAGE ; \ feed form to new page \ NO-ROOM? ENTRY PRINT Ham 12:00 11/01/92 : NO-ROOM? ( - flag ) \ true if not enough lines left on page 60 LINE# - #LINES < ; : ENTRY NO-ROOM? IF FOOTER PTITLE THEN PRINT-ENTRY ; : PROGRESS CONSOLE 25 8 GOTOXY ." Currently printing record " THIS 1+ . ." of " #RECS @ . PRINTER ; : PRINT CLS SCRTITLE #RECS @ ?DUP IF 1 EQU PAGE# 0 EQU THIS PRINTER PTITLE 0 DO I @RECORD PROGRESS ENTRY LOOP FOOTER CONSOLE ELSE 2CR ." No entries in file." BELL PRESS THEN ; \ The program Ham 12:00 11/01/92 CREATE ROUTINES ] GETENTRY REVIEW PRINT BYE [ ' TITLE vIDENT ! \ establish sign-on screen : RUN SETUP3 OPEN-FILE GETFILE BEGIN CLS SCRTITLE 0 GETOPTION ( option no. now on stack ) WSIZE * ROUTINES + PERFORM AGAIN ; \ TURNKEY RUN ADDRESS \ The above phrase--TURNKEY RUN ADDRESS--will create the \ program ADDRESS.EXE from the compiled code.
